home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / inspect-detail.stk < prev    next >
Encoding:
Text File  |  1995-07-19  |  19.4 KB  |  545 lines
  1. ;******************************************************************************
  2. ;
  3. ; Project       : STk-inspect, a graphical debugger for STk.
  4. ;
  5. ; File name     : inspect-detail.stk
  6. ; Creation date : Aug-30-1993
  7. ; Last update   : Sep-17-1993
  8. ;
  9. ;******************************************************************************
  10. ;
  11. ; This file implements the different kinds of "Detailers".
  12. ;
  13. ;******************************************************************************
  14.  
  15. (provide "inspect-detail")
  16.  
  17. (define Bug-correction read-from-string)
  18. ;---- detailer widget
  19.  
  20. (define DETAILER_WIDGET_NAME ".detailer")
  21. (define detailed-objects-list ())
  22.  
  23. (define (detail-tl-wid obj) (widget DETAILER_WIDGET_NAME (object-symbol obj)))
  24. (define (detail-tl-str obj) (& DETAILER_WIDGET_NAME (object-symbol obj)))
  25. (define (detail-l-wid obj) (widget (detail-tl-str obj) ".f1.l"))
  26. (define (detail-l-str obj) (& (detail-tl-str obj) ".f1.l"))
  27. (define (detail-e-wid obj) (widget (detail-tl-str obj) ".f1.e"))
  28. (define (detail-e-str obj) (& (detail-tl-str obj) ".f1.e"))
  29. (define (detail-m-wid obj) (widget (detail-tl-str obj) ".menu.command.m"))
  30. (define (detail-m-str obj) (& (detail-tl-str obj) ".menu.command.m"))
  31.  
  32. (define (detailed? obj) (member obj detailed-objects-list))
  33.  
  34. (define (detail obj)
  35.   (if (member (inspect::typeof (inspect::eval obj))
  36.           '(list pair vector closure widget))
  37.       [unless (detailed? obj) (detail-object obj)]
  38.       [error "The object ~s can not be detailed" obj]))
  39.  
  40. (define (detail-object obj)
  41.   (set! detailed-objects-list (cons obj detailed-objects-list))
  42.   (unless (object-infos obj)
  43.       (add-object-infos obj)
  44.       (if (symbol? obj) (trace-var obj `(update-object ',obj))))
  45.   (let ((obj-val (inspect::eval obj)))
  46.     (case (inspect::typeof obj-val)
  47.       ((list pair vector) (detail-VPL obj))
  48.       ((closure)          (detail-procedure obj))
  49.       ((widget)       (when (= (winfo 'exists (detail-tl-wid obj-val)) 0)
  50.                 (detail-widget obj))))))
  51.  
  52. (define (undetail obj)
  53.   (if (detailed? obj) (undetail-object obj)))
  54.  
  55. (define (undetail-object obj)
  56.   (let ((top (detail-tl-wid obj)))
  57.     (set! detailed-objects-list (list-remove obj detailed-objects-list))
  58.     (if (inspected? obj) ((inspect-m-wid obj) 'enable "Detail"))
  59.     (if (viewed? obj) ((view-m-wid obj) 'enable "Detail"))
  60.     (unless (or (inspected? obj) (viewed? obj))
  61.         (remove-object-infos obj)
  62.         (if (symbol? obj) (untrace-var obj)))
  63.     ;; If toplevel exists (i.e. it is not a <Destroy> event) destroy it
  64.     (if (= (winfo 'exists top) 1)
  65.     (destroy top))))
  66.  
  67. (define (detail-display obj)
  68.   (case (inspect::typeof (inspect::eval obj))
  69.     ((vector pair list) (detail-VPL-display obj))
  70.     ((closure) (detail-procedure-display obj))
  71.     ((widget) (detail-widget-display obj))))
  72.  
  73.  
  74. ;---- Detailer menu -----------------------------------------------------------
  75.  
  76. (define (detail-menu-Eval entry obj)
  77.   (eval-string (format #f "(set! ~a ~a)" obj [entry 'get])))
  78.  
  79. (define (detail-menu-Quote entry obj)
  80.   (eval-string (format #f "(set! ~a '~a)" obj [entry 'get])))
  81.  
  82. (define (detail-menu-Inspect key)
  83.   (let ((obj (find-object-infos key)))
  84.     (inspect obj)
  85.     ((widget (detail-tl-str obj) ".menu.command.m") 'disable "Inspect")
  86.     (if (viewed? obj) ((view-w-wid obj) 'disable "Inspect"))))
  87.  
  88. (define (detail-menu-Undetail key) (undetail (find-object-infos key)))
  89.  
  90. (define (detail-menu-View key)
  91.   (let ((obj (find-object-infos key)))
  92.     (view obj)
  93.     ((widget (detail-tl-str obj) ".menu.command.m") 'disable "View")
  94.     (if (inspected? obj) ((inspect-m-wid obj) 'disable "View"))))
  95.  
  96.  
  97. ;---- VPL menu ----------------------------------------------------------------
  98.  
  99. (define (get-VPL-index obj)
  100.   (let ((s (tk-get (VPL-l-wid obj) :text)))
  101.     (string->number (substring s 6 (string-length s)))))
  102.  
  103. (define (get-VPL-value obj) [(VPL-e-wid obj) 'get])
  104.  
  105. (define (set-VPL-index&value obj index)
  106.   (tk-set! (VPL-l-wid obj) :text (& "Value " index))
  107.   (let ((value-w (VPL-e-wid obj)))
  108.     (value-w 'delete 0 'end)
  109.     (value-w 'insert 0 (->object (Bug-correction [(VPL-vlb-wid obj) 'get index])))))
  110.  
  111. (define (VPL-menu-Eval obj)
  112.   (define index (get-VPL-index obj))
  113.   ((VPL-vlb-wid obj) 'delete index)
  114.   ((VPL-vlb-wid obj) 'insert index
  115.              (->object (eval-string (get-VPL-value obj))))
  116.   (modify-VPL obj))
  117.  
  118. (define (VPL-menu-Quote obj)
  119.   (define index (get-VPL-index obj))
  120.   ((VPL-vlb-wid obj) 'delete index)
  121.   ((VPL-vlb-wid obj) 'insert index (get-VPL-value obj))
  122.   (modify-VPL obj))
  123.  
  124.  
  125. ;---- VPL detailer ------------------------------------------------------------
  126.  
  127. (define (VPL-l-wid obj) (widget (detail-tl-str obj) ".value.l"))
  128. (define (VPL-l-str obj) (& (detail-tl-str obj) ".value.l"))
  129. (define (VPL-e-wid obj) (widget (detail-tl-str obj) ".value.e"))
  130. (define (VPL-e-str obj) (& (detail-tl-str obj) ".value.e"))
  131. (define (VPL-ilb-wid obj) (widget (detail-tl-str obj) ".list.lb1"))
  132. (define (VPL-ilb-str obj) (& (detail-tl-str obj) ".list.lb1"))
  133. (define (VPL-vlb-wid obj) (widget (detail-tl-str obj) ".list.lb2"))
  134. (define (VPL-vlb-str obj) (& (detail-tl-str obj) ".list.lb2"))
  135.  
  136. (define (create-detail-toplevel-widget obj)
  137.   (define w (create-toplevel-widget (detail-tl-str obj)))
  138.   (define id-w (widget w ".id"))
  139.   (define menu-w (widget w ".menu"))
  140.   (set-id-label1 id-w "Object" 6)
  141.   (set-id-label2 id-w "Value" 6)
  142.   ((widget menu-w ".help.m") 'add 'command :label "Detailer"
  143.                  :command '(stk:make-help Detailer-help))
  144.   (pack [menubutton (& menu-w ".command") :text "Command"] :side "left")
  145.   (define cmd-w (eval [menu (& menu-w ".command.m")]))
  146.   (tk-set! (widget menu-w ".command") :menu cmd-w)
  147.   (cmd-w 'add 'command :label "Inspect" 
  148.                 :command `(detail-menu-Inspect ',(object-symbol obj)))
  149.   (if (inspected? obj) (cmd-w 'disable "Inspect"))
  150.   (cmd-w 'add 'command :label "Undetail"
  151.                 :command `(detail-menu-Undetail ',(object-symbol obj)))
  152.   (cmd-w 'add 'command :label "View" 
  153.                :command `(detail-menu-View ',(object-symbol obj)))
  154.   (if (viewed? obj) (cmd-w 'disable "View"))
  155.  
  156.   (if (modifiable-object? obj)
  157.       [begin
  158.     (bind (widget w ".id.f2.e") "<Return>" 
  159.           `(detail-menu-Eval |%W| ',obj))
  160.     (bind (widget w ".id.f2.e") "<Shift-Return>" 
  161.           `(detail-menu-Quote |%W| ',obj))]
  162.       [begin
  163.     (set-id-value id-w (format #f "~S" (inspect::eval obj)))
  164.     (inspect::shadow-entry (widget w ".id.f2.e"))])
  165.   
  166.   (bind w "<Destroy>" `(detail-menu-Undetail ',obj))
  167.   w)
  168.  
  169. (define (detail-VPL obj)
  170.   (define w (create-detail-toplevel-widget obj))
  171.   ((widget w ".menu.help.m") 'add 'command)
  172.   (tk-set! (widget w ".id.f1.l2") :width 20)
  173.   (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  174.   (pack [frame (& w ".value")] :side "top" :fill "x" :padx 4 :pady 2)
  175.   (pack [label (& w ".value.l") :text "Value 0"] :side "left")
  176.   (pack [entry (& w ".value.e") :relief "sunken" :bd 2] :fill "x")
  177.   (pack [frame (& w ".list") :relief "sunken" :bd 2]
  178.     :fill "both" :expand "yes" :padx 4 :pady 2)
  179.   (pack [scrollbar (& w ".list.vsb") :orient "vertical"]
  180.     [listbox (& w ".list.lb1") :relief "raised" :bd 2 :geometry "4x8"]
  181.     :side "left" :fill "y")
  182.   (pack [listbox (& w ".list.lb2") :relief "raised" :bd 2]
  183.     :fill "both" :expand "yes")
  184.   (tk-listbox-single-select (& w ".list.lb1") (& w ".list.lb2"))
  185.   (if (modifiable-object? obj)
  186.       [begin
  187.     (bind (widget w ".value.e") "<Return>" `(VPL-menu-Eval ',obj))
  188.     (bind (widget w ".value.e") "<Shift-Return>" `(VPL-menu-Quote ',obj))]
  189.       [inspect::shadow-entry (widget w ".value.e")])
  190.  
  191.   (bind (widget w ".list.lb1") "<Button-1>" `(VPL-select ',obj %y))
  192.   (bind (widget w ".list.lb2") "<Button-1>" `(VPL-select ',obj %y))
  193.   (tk-set! (widget w ".list.vsb") :command (& "scroll-VPL " w))
  194.   (tk-set! (widget w ".list.lb2") :yscroll (& w ".list.vsb 'set"))
  195.   (detail-VPL-display obj))
  196.  
  197. (define (VPL-select obj y)
  198.   (let ((index-w (VPL-ilb-wid obj))
  199.     (value-w (VPL-vlb-wid obj))
  200.     (entry-w (VPL-e-wid obj))
  201.     (index ()))
  202.     [value-w 'select 'from [value-w 'nearest y]]
  203.     (set! index [value-w 'curselection])
  204.     (tk-set! (VPL-l-wid obj) :text (& "Value " index))
  205.     (let ((state [tk-get entry-w :state]))
  206.       (tk-set! entry-w :state "normal")
  207.       (entry-w 'delete 0 'end)
  208.       [entry-w 'insert 0 (->object (Bug-correction [value-w 'get index]))]
  209.       (tk-set! entry-w :state state))
  210.     [focus entry-w]))
  211.   
  212. (define (scroll-VPL w . param)
  213.   ((widget w ".list.lb1") 'yview (car param))
  214.   ((widget w ".list.lb2") 'yview (car param)))
  215.  
  216. (define (select-VPL-value w index)
  217.   (let ((index-l (widget w ".value.l"))
  218.     (value-e (widget w ".value.e")))
  219.     (tk-set! index-l :text index)
  220.     (value-e 'delete 0 'end)
  221.     (value-e 'insert 0 (->object 
  222.             (Bug-correction ((widget w ".list.lb2") 'get index))))
  223.     (focus value-e)))
  224.  
  225. ;---- VPL display
  226.  
  227. (define (detail-VPL-display obj)
  228.   (define id-w (& (detail-tl-str obj) ".id"))
  229.   (set-id-object id-w (->object obj))
  230.   (set-id-value id-w (->object (inspect::eval obj)))
  231.   (case (inspect::typeof (inspect::eval obj))
  232.     ((list) (detail-VPL-display-list obj))
  233.     ((pair) (detail-VPL-display-pair obj))
  234.     ((vector) (detail-VPL-display-vector obj)))
  235.   (let ((index (get-VPL-index obj)))
  236.     (if (< index [(VPL-ilb-wid obj) 'size])
  237.     (set-VPL-index&value obj index)
  238.     (set-VPL-index&value obj 0))))
  239.  
  240. (define (detail-VPL-display-list obj)
  241.   (define w (detail-tl-wid obj))
  242.   (wm 'title w "List detailer")
  243.   ((widget w ".menu.help.m") 'entryconfig 2 :label "List detailer"
  244.                  :command '(stk:make-help List-detailer-help))
  245.   (let ((obj-val (inspect::eval obj))
  246.     (index-w (VPL-ilb-wid obj))
  247.     (value-w (VPL-vlb-wid obj))
  248.     (index 0))
  249.     (index-w 'delete 0 'end)
  250.     (value-w 'delete 0 'end)
  251.     (until (null? obj-val)
  252.        (index-w 'insert 'end index)
  253.        (value-w 'insert 'end (->object (car obj-val)))
  254.        (set! obj-val (cdr obj-val))
  255.        (set! index (+ index 1)))))
  256.  
  257. (define (detail-VPL-display-pair obj)
  258.   (define w (detail-tl-wid obj))
  259.   (wm 'title w "Pair detailer")
  260.   ((widget w ".menu.help.m") 'entryconfig 2 :label "Pair detailer"
  261.                  :command '(stk:make-help Pair-detailer-help))
  262.   (let ((obj-val (inspect::eval obj))
  263.     (index-w (VPL-ilb-wid obj))
  264.     (value-w (VPL-vlb-wid obj))
  265.     (index 0))
  266.     (index-w 'delete 0 'end)
  267.     (value-w 'delete 0 'end)
  268.     (while (pair? obj-val)
  269.        (index-w 'insert 'end index)
  270.        (value-w 'insert 'end (->object (car obj-val)))
  271.        (set! obj-val (cdr obj-val))
  272.        (set! index (+ index 1)))
  273.     (index-w 'insert 'end (& "." index))
  274.     (value-w 'insert 'end (->object obj-val))))
  275.  
  276. (define (detail-VPL-display-vector obj)
  277.   (define w (detail-tl-wid obj))
  278.   (wm 'title w "Vector detailer")
  279.   ((widget w ".menu.help.m") 'entryconfig 2 :label "Vector detailer"
  280.                  :command '(stk:make-help Vector-detailer-help))
  281.   (let* ((obj-val (inspect::eval obj))
  282.      (length (vector-length obj-val))
  283.      (index-w (VPL-ilb-wid obj))
  284.      (value-w (VPL-vlb-wid obj)))
  285.     (index-w 'delete 0 'end)
  286.     (value-w 'delete 0 'end)
  287.     (for ((index 0 (+ index 1)))
  288.      (< index length)
  289.      (index-w 'insert 'end index)
  290.      (value-w 'insert 'end (->object (vector-ref obj-val index))))))
  291.  
  292. ;---- VPL modify
  293.  
  294. (define (modify-VPL obj)
  295.   (case (inspect::typeof (inspect::eval obj))
  296.     ((list) (modify-VPL-list obj))
  297.     ((pair) (modify-VPL-pair obj))
  298.     ((vector) (modify-VPL-vector obj))))
  299.  
  300. (define (modify-VPL-list obj)
  301.   (let* ((value-w (VPL-vlb-wid obj))
  302.      (cmd (format #f "(set! ~S '(" obj))
  303.      (size (value-w 'size)))
  304.     (for ((i 0 (+ i 1)))
  305.      (< i size)
  306.      (set! cmd (string-append cmd 
  307.                   (->object (Bug-correction (value-w 'get i)))
  308.                   " ")))
  309.     (set! cmd (string-append cmd "))"))
  310.     (eval-string cmd)))
  311.  
  312. (define (modify-VPL-pair obj)
  313.   (let* ((value-w (VPL-vlb-wid obj))
  314.      (cmd (format #f "(set! ~S '(" obj))
  315.      (size (value-w 'size))
  316.      (size-1 (- size 1)))
  317.     (for ((i 0 (+ i 1)))
  318.      (< i size-1)
  319.      (set! cmd (string-append cmd 
  320.                   (->object (Bug-correction (value-w 'get i)))
  321.                   " ")))
  322.     (set! cmd (string-append cmd 
  323.                  ". " 
  324.                  (->object (Bug-correction (value-w 'get size-1)))
  325.                  "))"))
  326.     (eval-string cmd)))
  327.  
  328. (define (modify-VPL-vector obj)
  329.   (let* ((value-w (VPL-vlb-wid obj))
  330.      (cmd (format #f "(set! ~S '#(" obj))
  331.      (size (value-w 'size)))
  332.     (for ((i 0 (+ i 1)))
  333.      (< i size)
  334.      (set! cmd (string-append cmd 
  335.                   (->object (Bug-correction (value-w 'get i)))
  336.                   " ")))
  337.     (set! cmd (string-append cmd "))"))
  338.     (eval-string cmd)))
  339.  
  340.  
  341.  
  342.  
  343. ;---- Procedure detailer ------------------------------------------------------
  344.  
  345. (define (inspect::pretty-print body) (pp (uncode body) #f))
  346.  
  347. (define (detail-procedure-set obj)
  348.   (define text-w (widget (detail-tl-str obj) ".body.t"))
  349.   (eval-string (format #f "(set! ~a ~a)" obj (text-w 'get "1.0" 'end))))
  350.  
  351. (define (detail-procedure obj)
  352.   (define w (create-detail-toplevel-widget obj))
  353.   (wm 'title w "Procedure detailer")
  354.   (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  355.   ((widget w ".menu.help.m") 'add 'command :label "Procedure detailer"
  356.                  :command '(stk:make-help Procedure-detailer-help))
  357.   (pack [label (& w ".menu.set") :text "Set"] :side "left")
  358.   (bind (widget w ".menu.set") "<ButtonPress-1>" `(detail-procedure-set ',obj))
  359.   (pack [frame (& w ".body") :relief "sunken" :bd 2]
  360.     :fill "both" :expand "yes" :padx 4 :pady 2)
  361.   (pack [scrollbar (& w ".body.vsb")
  362.            :orient "vertical"
  363.            :command (format #f "~a 'yview" (& w ".body.t"))]
  364.     :side "left" :fill "y")
  365.   (pack [text (& w ".body.t")
  366.           :relief "raised" :bd 2 :width 60 :height 16
  367.           :yscroll (format #f "~a 'set" (& w ".body.vsb"))]
  368.     :fill "both" :expand "yes")
  369.   (detail-procedure-display obj))
  370.  
  371. (define (detail-procedure-display obj)
  372.   (define obj-val (inspect::eval obj))
  373.   (define id-w (& (detail-tl-str obj) ".id"))
  374.   (set-id-object id-w (->object obj))
  375.   (set-id-value id-w (->object obj-val))
  376.   (define body (procedure-body obj-val))
  377.   (define text-w (widget (detail-tl-str obj) ".body.t"))
  378.   (tk-set! text-w :state "normal")
  379.   (text-w 'delete "1.0" 'end)
  380.   (text-w 'insert "1.0" (inspect::pretty-print body))
  381.   (unless (symbol? obj)
  382.      (inspect::shadow-entry text-w)))
  383.  
  384.  
  385. ;---- Widget detailer ---------------------------------------------------------
  386.  
  387. (define (detail-widget obj)
  388.   (define w (create-detail-toplevel-widget obj))
  389.   (wm 'title w "Widget detailer")
  390.   (tk-set! (widget w ".id.f1.l2") :width 40)
  391.   ((widget w ".menu.help.m") 'add 'command :label "Widget detailer"
  392.                  :command '(stk:make-help Widget-detailer-help))
  393.   (pack [menubutton (& w ".menu.bindings") :text "Bindings"] :side "left")
  394.   (tk-set! (widget w ".menu.bindings") :menu [menu (& w ".menu.bindings.m")])
  395.   (detail-widget-create-options obj)
  396.   (detail-widget-display obj))
  397.  
  398. (define (detail-widget-create-options obj)
  399.   (define w-str (detail-tl-str obj))
  400.   (catch (destroy (& w-str ".options")))
  401.   (pack [frame (& w-str ".options") :relief "raised" :bd 2]
  402.     :fill "both" :expand "yes" :padx 4 :pady 2)
  403.   (pack [frame (& w-str ".options.class")] 
  404.     :side "top" :fill "x" :padx 4 :pady 4)
  405.   (pack [label (& w-str ".options.class.l1")
  406.            :text "Class" :width 16 :anchor "e"]
  407.     :side "left")
  408.   (pack [label (& w-str ".options.class.l2")
  409.            :relief "groove" :bd 2 :anchor "w" :font ITALIC-MEDIUM_FONT]
  410.     :fill "x")
  411.   (let ((options-infos ((eval obj) 'config))
  412.     (i 1))
  413.     (for-each
  414.      (lambda (infos)
  415.        (if (= 5 (length infos))
  416.        (let ((option-w (& w-str ".options.f" i))
  417.          (s        (symbol->string (car infos))))
  418.          (pack [frame option-w] :side "top" :fill "x" :padx 4)
  419.          (pack [label (& option-w ".l")
  420.               :text (substring s 1 (string-length s))
  421.               :width 16 :anchor "e"]
  422.            :side "left")
  423.          (pack [entry (& option-w ".e") :relief "sunken" :bd 2] :fill "x")
  424.          (bind (& option-w ".e") "<Return>"      `(WID-eval-option ',obj |%W|))
  425.          (bind (& option-w ".e") "<Shift-Return>"`(WID-quote-option ',obj |%W|))
  426.          (set! i (+ i 1)))))
  427.      options-infos))
  428.   (pack [frame (& w-str ".options.children")]
  429.     :side "top" :fill "x" :padx 4 :pady 4)
  430.   (pack [label (& w-str ".options.children.1")
  431.            :text "Children" :width 16 :anchor "e"]
  432.     :side "left")
  433.   (pack [entry (& w-str ".options.children.e")
  434.            :relief "groove" :bd 2 :state "disabled" :font MEDIUM_FONT]
  435.     :fill "x")
  436.   (update 'idletasks)
  437.   (define req-h (winfo 'reqheight w-str))
  438.   (wm 'minsize w-str 0 req-h)
  439.   (wm 'maxsize w-str SCREEN_WIDTH req-h))
  440.  
  441. (define (WID-bindings-menu-str obj) (& (detail-tl-str obj) ".menu.bindings.m"))
  442. (define (WID-bindings-menu-wid obj)
  443.   (widget (detail-tl-str obj) ".menu.bindings.m"))
  444.  
  445. (define (binding->string binding)
  446.   (let ((binding (if (string? binding) binding (symbol->string binding))))
  447.     (substring binding 1 (- (string-length binding) 1))))
  448.  
  449. (define (WID-bindings-menu-add obj binding)
  450.   (if (catch ((WID-bindings-menu-wid obj) 'index binding))
  451.       ((WID-bindings-menu-wid obj) 'add 'command 
  452.        :label    (symbol->string binding)
  453.        :command `(show-binding ',(object-symbol obj) 
  454.                    ,(symbol->string  binding)))))
  455.  
  456. (define (show-binding key binding)
  457.   (let* ((obj     (find-object-infos key))
  458.      (obj-val (inspect::eval obj))
  459.      (name    (string-lower (binding->string binding)))
  460.      (body    (bind obj-val binding)))
  461.     
  462.     (if (null? body) (set! body (bind (winfo 'class obj-val) binding)))
  463.     ((WID-bindings-menu-wid obj) 'disable binding)
  464.     (define w (& (detail-tl-str obj) "._" name))
  465.     (create-toplevel-widget w)
  466.     (wm 'title w "Widget binding")
  467.     (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  468.     (set-id-label1 (& w ".id") "Widget" 6)
  469.     (set-id-object (& w ".id") (->object obj))
  470.     (set-id-label2 (& w ".id") "Binding" 6)
  471.     (set-id-value (& w ".id") binding)
  472.     (inspect::shadow-entry (string->widget (& w ".id.f2.e")))
  473.     (pack [button (& w ".menu.dismiss") 
  474.           :text "Dismiss" 
  475.           :relief "flat"
  476.           :command `(begin 
  477.                   ((WID-bindings-menu-wid ,obj-val) 
  478.                            'enable ',binding)
  479.                   (destroy ,w))]
  480.       :side "left")
  481.  
  482.     (pack [button (& w ".menu.set") 
  483.           :text "Set binding"
  484.           :relief "flat"
  485.           :command `(bind ,obj-val ,binding [(widget ,w ".body.t")
  486.                              'get "1.0" 'end])]
  487.       :side "left")
  488.     (pack [frame (& w ".body") :relief "sunken" :bd 2]
  489.       :fill "both" :expand "yes" :padx 4 :pady 2)
  490.     (pack [scrollbar (& w ".body.vsb") :orient "vertical"]
  491.       :side "left" :fill "y")
  492.     (pack [text (& w ".body.t") :relief "raised" :bd 2 :width 60 :height 8]
  493.       :fill "both" :expand "yes")
  494.     ((widget w ".body.t") 'insert "1.0" (inspect::pretty-print body))))
  495.  
  496.  
  497. (define (detail-widget-display obj)
  498.   (define obj-val (inspect::eval obj))
  499.   (define w-str (detail-tl-str obj))
  500.   (define id-w (widget w-str ".id"))
  501.   (set-id-object id-w (->object obj))
  502.   (set-id-value id-w (->object obj-val))
  503.   (tk-set! (widget w-str ".options.class.l2") :text (winfo 'class obj-val))
  504.   (define children-w (widget w-str ".options.children.e"))
  505.   (tk-set! children-w :state "normal")
  506.   (children-w 'delete 0 'end)
  507.   (children-w 'insert 0 (winfo 'children obj-val))
  508.   (tk-set! children-w :state "disabled")
  509.   (let ((options-infos (obj-val 'config))
  510.     (i 1))
  511.     (for-each
  512.      (lambda (infos)
  513.        (if (= 5 (length infos))
  514.        (let ((option-w (widget w-str ".options.f" i ".e")))
  515.          (option-w 'delete 0 'end)
  516.          (option-w 'insert 0 (list-ref infos 4))
  517.          (set! i (+ i 1)))))
  518.      options-infos))
  519.   (define menu-w (WID-bindings-menu-wid obj))
  520.   (menu-w 'delete 0 'last)
  521.   (for-each (lambda (binding) (WID-bindings-menu-add obj binding))
  522.         (bind obj-val))
  523.   (menu-w 'add 'separator)
  524.   (for-each (lambda (binding) (WID-bindings-menu-add obj binding))
  525.         (bind [winfo 'class obj-val])))
  526.  
  527. (define (WID-eval-option obj window)
  528.   (let ((parent (winfo 'parent window)))
  529.     (eval-string 
  530.      (format #f "(tk-set! ~a :~a ~s)"
  531.             obj
  532.         (tk-get (widget parent ".l") :text)
  533.         (eval-string (window 'get))))))
  534.  
  535. (define (WID-quote-option obj window)
  536.  (let ((parent (winfo 'parent window)))
  537.     (eval-string 
  538.      (format #f "(tk-set! ~a :~a ~s)"
  539.             obj
  540.         (tk-get (widget parent ".l") :text)
  541.         (window 'get)))))
  542.  
  543.  
  544.  
  545.